home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / Clone / saveimage.f < prev    next >
Encoding:
FORTH Source  |  1992-05-27  |  5.0 KB  |  248 lines
  1. \ save-image <name> <file> [options]
  2. \
  3. \ where: <name> is the word to set as _main
  4. \
  5. \        <file> is the name of the executable file that
  6. \               will be created.
  7. \
  8. \       options ... -s will include a Symbol Table in the executable.
  9. \                   -m will write a Map file (same format as STATS)
  10. \
  11. \ .........  THIS COMMAND PARSES THE ENTIRE INPUT LINE  ...........
  12.  
  13. only forth definitions
  14.  
  15. ANEW task-saveimage.f
  16.  
  17. also TGT definitions
  18.  
  19.  
  20. variable +Symbols   +symbols on
  21. variable +Map       +Map off
  22. variable +Icon
  23.  
  24. variable OverlayMain
  25.  
  26. : AddSDU  ( InTGTindex -- , Add SYMBOL DATA UNIT )
  27.   >r
  28.   r@ InDictBase stack@   ( -- origpfa )  dup PacketFor ..@ ref_IsPFA
  29.   IF
  30.      pad 32 erase
  31.      ( -- pfa )  >name dup c@ $ 1f and   ( -- nfa cnt )
  32.      swap 1+  over  pad  swap move       ( -- cnt )
  33.      cell /mod swap
  34.      IF
  35.         1+
  36.      THEN
  37.      ( -- #cells )  dup save,  pad swap 0
  38.      DO
  39.         ( -- addr ) dup @ save, cell+
  40.      LOOP
  41.      drop   r@ InTGTBase stack@ save,
  42.   ELSE
  43.      drop
  44.   THEN
  45.   rdrop
  46. ;
  47.  
  48.  
  49. : AddSymbolTable  ( -- )
  50.   $ 3f0  ( hunk_symbol )  save,
  51.   TargetTables   \ build the 3 tables  (see STATS.F)
  52.   InTGTBase freecell 0
  53.   DO
  54.      i AddSDU
  55.   LOOP
  56.   0 save,
  57. ;
  58.  
  59.  
  60. : WriteTGTRelocs?  ( -- )
  61.   TargetABSVAR @
  62.   IF   \ ." writing hunk_reloc32..." cr
  63.  
  64.        hunk_reloc32   save,
  65.        TargetABSBase Freecell  dup save,   ( --  #reloc )
  66.        0 save,    ( hunk# to link with )   0
  67.        DO  
  68.           i TargetABSBASE stack@  ( relocaddr1 -- )  save,
  69.        LOOP
  70.        0 save,    ( no more relocs )
  71.   THEN
  72. ;
  73.  
  74.  
  75. : WRITE-IMAGE  ( fptr -- )
  76.   tempfile !   save-error off
  77.   \
  78.   \ Alloc a virtual-buffer...
  79.   \
  80.   TempBuff openfv drop
  81.   \
  82.   \ Calc #bytes in image (to nearest cell)...
  83.   \
  84.   TargetImageBase FreeByte  cell /mod swap
  85.   IF
  86.      1+
  87.   THEN   cells
  88.   \
  89.   \ ( -- #bytes )  Write the HUNK_HEADER...
  90.   \
  91.   #relocs @ >r   relocs @ >r      ( -- #codebytes )
  92.   \
  93.   \
  94.   CloneOverlay @
  95.   IF
  96.      OverlayMain @ save,
  97.   ELSE
  98.      TargetABSVAR @
  99.      IF
  100.         TargetABSBASE freecell
  101.      ELSE
  102.         0
  103.      THEN   #relocs !   TargetABSVAR @ relocs !
  104.      dup  DictionarySize @ cell/ cells +   write_hunk_header
  105.      \
  106.      \ ( -- #bytes )  Write the HUNK_CODE...
  107.      \
  108.      hunk_code save, dup  DictionarySize @ +  cell/ save,
  109.   THEN
  110.   ( -- #bytes )
  111.   TargetImageBase  swap 0
  112.   DO
  113.      dup @ save,   cell+  cell
  114.   +LOOP
  115.   drop    ( -- )
  116.   CloneOverlay @ 0=
  117.   IF
  118.      DictionarySize @ cell/  0
  119.      DO
  120.         0 save,
  121.      LOOP
  122.      \
  123.      \ Write any Symbol Table...
  124.      \
  125.      +Symbols @
  126.      IF
  127.         AddSymbolTable
  128.      THEN
  129.      WriteTGTRelocs?
  130.      \
  131.      \ HUNK_END ...
  132.      \
  133.      hunk_end save,
  134.      \
  135.      \ empty-hunk...
  136.      \
  137.      write_hunk_empty
  138.   THEN
  139.   save-error @
  140.   IF    ." Error writing file." cr
  141.   ELSE  +Icon @
  142.         IF  MakeIcon
  143.         THEN
  144.   THEN  tempfile @  tempbuff closeFVWrite
  145.   tempfile @  fclose
  146.   r> relocs !   r> #relocs !
  147. ;
  148.  
  149. : writestats  ( -- )
  150.   " .map" count here $append
  151.   skip-word? on  logto  stats  logend
  152. ;
  153.  
  154. : SetOptions  ( -- , parses remainder of line for options )
  155.   +symbols off   +map off   +icon off
  156.   CloneOverlay @ 0=
  157.   IF
  158.      [compile] \
  159.      pushtib
  160.      here 1+  tib  here c@    dup tib + 0 swap odd!   dup #tib !    move
  161.      >in off  tibend off
  162.      fblk dup @ >r off
  163.      blk  dup @ >r off
  164.      BEGIN
  165.         bl word c@
  166.      WHILE
  167.         here " -S" $=
  168.         IF
  169.            +symbols on
  170.         THEN
  171.         here " -M" $=
  172.         IF
  173.            +map on
  174.         THEN
  175.         here " -ICON" $=
  176.         IF
  177.            +icon on
  178.         THEN
  179.      REPEAT
  180.      pulltib
  181.      r> blk !    r> fblk !
  182.   THEN
  183. ;
  184.  
  185. also Forth Definitions
  186.  
  187.  
  188. : Save-Image  ( -- , <name> )  >newline
  189. \ x ) dbgon >newline ." Entering Save-Image..." cr .s >newline dbgoff
  190.   \
  191.   \ Is there a target word with that name?
  192.   \
  193.   CloneOverlay @
  194.   IF
  195.      CloneInputCFA @
  196.   ELSE
  197.      [compile] '
  198.   THEN
  199.   ( res-pfa )  dup references stackfind   ( -- respfa ix flag )
  200.   IF
  201.      drop  PacketFor dup ..@ ref_resolved   ( -- pkt flag )
  202.      IF
  203.         \
  204.         \ Set _main in the image...
  205.         \
  206.         ..@ ref_TgtAdr  ( -- tgtadr )  CloneOverlay @
  207.         IF
  208.            OverlayMain !
  209.         ELSE
  210.            ' _main >TargetAdr   Target!   ( -- )
  211. \ x ) dbgon >newline ." Set the Initial DP..." cr .s >newline dbgoff
  212.            \
  213.            \ Set the Initial DP...
  214.            \
  215.            TargetHERE  ' DP  >TargetAdr  Target!
  216.         THEN
  217.         \
  218.         \ Create the file...
  219.         \
  220.         new fopen  -dup
  221.         IF
  222. \ x ) dbgon >newline ." before SetOptions..." cr .s >newline dbgoff
  223.            SetOptions
  224. \ x ) dbgon >newline ." after SetOptions..." cr .s >newline dbgoff
  225.            write-image
  226. \ x ) dbgon >newline ." after write-image..." cr .s >newline dbgoff
  227.            +Map @
  228.            IF
  229.              writestats
  230.            THEN
  231.         ELSE
  232.             ." Can't write image file!" quit
  233.         THEN
  234.      ELSE
  235.         here count type ."  is not resolved!"  quit
  236.      THEN
  237.   ELSE
  238.      here count type ."  is not defined in the Target file!"  quit
  239.   THEN
  240. ;
  241.  
  242. : Save-Overlay  ( -- , uses last cloned word )
  243.   save-image
  244. ;
  245.  
  246. only forth definitions
  247. also TGT
  248.